home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 10.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  50.6 KB  |  1,720 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "libhdr.h"
  12. #include "vars.h"
  13. #include "ifile.h"
  14. #include "chapprots.h"
  15. #include "setprots.h"
  16. #include "smiscprots.h"
  17. #include "miscprots.h"
  18. #include "libprots.h"
  19. #include "libwprots.h"
  20. #include "dclmapprots.h"
  21. #include "dbxprots.h"
  22. #include "errmsgprots.h"
  23.  
  24. int save_trace_opt = 0;
  25. /* chapter 10 */
  26.  
  27. static Tuple context;
  28.  
  29. static void init_compunit();
  30. static void save_comp_info(Node);
  31. static void save_tree(Node, int);
  32. static void renumber_nodes(char *);
  33. static void collect_unit_nodes(Symbol);
  34. static void generic_declarations(Symbol, Unitdecl);
  35. static void save_proper_body_info(Node);
  36. static void save_package_instance_unit(Node);
  37. static void save_subprogram_instance_unit(Node);
  38. static void establish_context(Node);
  39. static void with_clause(Tuple, Node);
  40. static void elaborate_pragma(Node);
  41. static Tuple check_separate(Node);
  42. static Stubenv retrieve_env(Node, Node);
  43. static void remove_obsolete_stubs(char *);
  44. static char *get_unit(char *);
  45. static void new_unit_numbers(Node, unsigned);
  46.  
  47. /*TBSL: need to review calls to sasve_subprog_info now that
  48.  * it has an argument    ds 31 oct
  49.  */
  50.  
  51. extern IFILE *TREFILE, *AISFILE, *LIBFILE;
  52. static Tuple  elab_pragmas;
  53.  
  54. /* all_vis is tuple of unit-names */
  55.  
  56. static void init_compunit()                        /*;init_compunit*/
  57. {
  58.     int    i;
  59.  
  60.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  init_compunit;");
  61.  
  62.     /* Initialize tree nodes to unit number of the new compilation unit.*/
  63.     unit_number_now = unit_number(unit_name);
  64.     for (i = 1; i <= seq_node_n; i++)
  65.         N_UNIT((Node)seq_node[i]) = unit_number_now;
  66. }
  67.  
  68. void new_compunit(char *typ, Node name_node)    /*;new_compunit*/
  69. {
  70.     char    *name;
  71.  
  72.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_compunit");
  73.  
  74.     name = N_VAL(name_node);
  75.  
  76.     /* Establish global name and library name for new compilation unit. */
  77.     if (IS_COMP_UNIT){
  78.         remove_obsolete_stubs(name);
  79.         seq_symbol_n = 0;     /* reset symbol count */
  80.         unit_name = strjoin(typ, name);
  81.         init_compunit();
  82.     }
  83. }
  84.  
  85. /* chapter 10, part b*/
  86. void compunit(Node node)                            /*;compunit*/
  87. {
  88.     Node    unit_body;
  89.     Tuple    added_names;
  90.     char    *id;
  91.     Fortup    ft1;
  92.     Symbol    sym;
  93.     Fordeclared fd;
  94.  
  95.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  compunit;");
  96.  
  97.     elab_pragmas = tup_new(0);
  98.     stubs_to_write = set_new(0);
  99.     all_vis = tup_new(0);
  100.     /*context_node = N_AST1(node);*/
  101.     unit_body = N_AST2(node);
  102.     establish_context(node);
  103.     /* process unit only if there were no problems in processing context */
  104.     if (context != (Tuple)0)
  105.         adasem(unit_body);
  106.     if (errors == 0) {
  107.         /* If there are no errors in any comp unit in the file, collect global
  108.          * maps and library information after completion of this a compilation
  109.          * unit.
  110.          */
  111.         if (N_KIND(unit_body) == as_separate)
  112.             /* collect symbol table information for body (it is not a unit, 
  113.              * and must be saved explicitly here).
  114.              */
  115.             save_proper_body_info(unit_body);
  116.  
  117.         tup_frome(newtypes);
  118.  
  119.         if (N_KIND(unit_body) == as_insert) {
  120.             if (N_KIND(N_AST1(unit_body)) == as_subprogram_tr)
  121.                 /* for a subprogram instance, we place renaming code in the body
  122.                  * of the subprogram. If there is some additional instantiation 
  123.                  * code (bounds checks, etc.) it must be placed in a separate
  124.                  * unit on which the instantiation depends.
  125.                  */
  126.                 save_subprogram_instance_unit(node);
  127.             else
  128.                 /* Produce two units, one for spec instance and one for body. */
  129.                 save_package_instance_unit(node);
  130.         }
  131.         else {        /* any other kind of compilation unit.*/
  132.             save_comp_info(node);
  133.         }
  134.     }
  135.     /* Reinitialize compilation environment. */
  136.  
  137.     unit_name = strjoin("","");
  138.     newtypes = tup_with(newtypes, (char *) tup_new(0));
  139.     /*   DECLARED := BASE_DECLARED;
  140.      * Delete symbols placed in standard0 by previous compilation,
  141.      * restoring standard0 to its initial state. added_names is a tuple
  142.      * of identifiers added in prior compilation.
  143.      */
  144.     added_names = tup_new(0); /* build tuple of added identifiers */
  145.     FORDECLARED(id, sym, DECLARED(symbol_standard0), fd);
  146.         if (sym != (Symbol)0 && S_UNIT(sym))
  147.             added_names = tup_with(added_names, id);
  148.     ENDFORDECLARED(fd);
  149.     FORTUP(id=(char *), added_names, ft1);
  150.         dcl_undef(DECLARED(symbol_standard0), id);
  151.     ENDFORTUP(ft1);
  152.     tup_free(added_names);
  153.  
  154.     DECLARED(symbol_unmentionable) = base_declared[1];
  155.     DECLARED(symbol_standard) = base_declared[2];
  156.     DECLARED(symbol_ascii) = base_declared[3];
  157.     FORDECLARED(id, sym, DECLARED(symbol_ascii), fd);
  158.         IS_VISIBLE(fd) = TRUE;
  159.     ENDFORDECLARED(fd);
  160.     scope_name = symbol_standard0;
  161.     open_scopes = tup_new(2);
  162.     open_scopes[1] = (char *)symbol_standard0;
  163.     open_scopes[2] = (char *)symbol_unmentionable;
  164.     used_mods = tup_new(0);
  165.     vis_mods = tup_new1((char *) symbol_ascii);
  166.     scope_st = tup_new(0);
  167.     return;
  168. }
  169.  
  170. static void save_comp_info(Node node)                    /*;save_comp_info*/
  171. {
  172.     /* Subsidiary to the previous procedure. In the case of a unit which is
  173.      * a package instantiation, the current procedure is called twice, to
  174.      * produce separate units for the instance spec and the instance body.
  175.      */
  176.  
  177.     Unitdecl    ud;
  178.     char    *v;
  179.     Tuple    tup;
  180.     Set        vis_units;
  181.     int        uindex, i, si;
  182.     struct unit *pUnit;
  183.     Fortup    ft1;
  184.     Forset    fs1;
  185.     Stubenv    ev;
  186.     char    *stub_name;
  187.  
  188.     vis_units = set_new(tup_size(all_vis));
  189.  
  190.     uindex = unit_number(unit_name);
  191.     pUnit = pUnits[uindex];
  192.     /*PRE_COMP(unit_name) := vis_units;*/
  193.     FORTUP(v=(char *), all_vis, ft1);
  194.         vis_units = set_with(vis_units, (char *) unit_numbered(v));
  195.     ENDFORTUP(ft1);
  196.     pUnit->aisInfo.preComp = (char *)vis_units;
  197.     pUnit->aisInfo.pragmaElab = (char *) tup_copy(elab_pragmas);
  198.  
  199.     /* Before writing out any info, set unit of all symbols allocated
  200.      * while compiling this unit to current unit number
  201.      */
  202.     for (i = 1; i <= seq_symbol_n; i++)
  203.         S_UNIT((Symbol)seq_symbol[i]) = uindex;
  204.  
  205.     save_tree(node, uindex);
  206.     update_lib_maps(unit_name, 'u');
  207.     pUnit->aisInfo.compDate = (char *) tup_new(0);
  208.  
  209.     /*UNIT_DECL(unit_name) +:= [CONTEXT, UNIT_NODES];    */
  210.     ud = unit_decl_get(unit_name);
  211.     if (ud == (Unitdecl)0)
  212.         chaos("save_comp_info: unit decl missing");
  213.     ud->ud_context = tup_copy(context);
  214.     ud->ud_nodes = tup_copy(unit_nodes);
  215.     unit_decl_put(unit_name, ud);
  216.     if (!errors) {
  217.         /* Stub environment info is now written after the tree nodes
  218.          * are renumbered in save_tree. Also in case of erros Stub info
  219.          * is not written to st1 file.
  220.          */
  221.         FORSET(si=(int), stubs_to_write, fs1)
  222.             stub_name = lib_stub[si];
  223.             tup = (Tuple) stub_info[si];
  224.             ev = (Stubenv) tup[2];
  225.             write_stub(ev, stub_name, "st1");
  226.         ENDFORSET(fs1);
  227.     }
  228.     if (!errors) write_ais(uindex);
  229. }
  230.  
  231. static void new_unit_numbers(Node root, unsigned newUnitNumber)
  232.                                                         /*;new_unit_number*/
  233. {
  234.     unsigned nodeKind;
  235.     Node listNode;
  236.     Fortup ft1;
  237.     Tuple listTuple;
  238.  
  239.     if (root == (Node)0 || root == OPT_NODE) return;
  240.     N_UNIT(root) = newUnitNumber;
  241.  
  242.     nodeKind = N_KIND(root);
  243.     if (N_AST1_DEFINED(nodeKind)) new_unit_numbers(N_AST1(root), newUnitNumber);
  244.     if (N_AST2_DEFINED(nodeKind)) new_unit_numbers(N_AST2(root), newUnitNumber);
  245.     if (N_AST3_DEFINED(nodeKind)) new_unit_numbers(N_AST3(root), newUnitNumber);
  246.     if (N_AST4_DEFINED(nodeKind)) new_unit_numbers(N_AST4(root), newUnitNumber);
  247.  
  248.     if (! N_LIST_DEFINED(nodeKind)) return;
  249.  
  250.     listTuple = N_LIST(root);
  251.     FORTUP(listNode=(Node), listTuple, ft1);
  252.         new_unit_numbers(listNode, newUnitNumber);
  253.     ENDFORTUP(ft1);
  254. }
  255.  
  256. static void save_tree(Node root, int uindex)        /*;save_tree*/
  257. {
  258.     /* This procedure builds a sequential list of all the nodes in the
  259.      * abstract syntax tree while performing a preorder scan of the tree.
  260.      * For a given node, all its components are  placed in a flat tuple
  261.      * "tree_node".     This tuple is then added to the list.
  262.      *
  263.      * For the C version, we need to traverse the tree to find the reachable
  264.      * nodes, which are built up in a string reach such that reach[i] is
  265.      * 1 if node with sequence number i is reachable, 0 otherwise.
  266.      * We then call write_tree (lib.c)  to actually write the tree.
  267.      */
  268.  
  269.     int    stack_max, stack_now, na, i, unit_now, nk;
  270.     Tuple    stack, a;
  271.     Node    nodes[5], n, nod;
  272.     char    *reach;
  273. #define STACK_INC 50
  274.  
  275.     if (TREFILE == (IFILE *)0) return;
  276.     reach = emalloct((unsigned) ( seq_node_n+2) , "reach");
  277.     reach[seq_node_n+1] = '\0'; /* mark end of string */
  278.     for (i=0; i <= seq_node_n; i++) reach[i] = '0';
  279.     stack_max = tup_size(unit_nodes) + STACK_INC;
  280.     stack = tup_new(stack_max);
  281.     for (i = 1; i <= tup_size(unit_nodes); i++){
  282.         stack[i] = unit_nodes[i];
  283. #ifdef SAVE_TRACE
  284.         save_trace("init_stack", i, (Node) stack[i]);
  285. #endif
  286.     }
  287.     stack_now = tup_size(unit_nodes);
  288.     /* NOTE: must have STACK_INC > size of init_nodes.
  289.      * We do not write nodes for predefined entities in C version.
  290.      */
  291.     unit_now = N_UNIT(root);
  292.     stack_now++;
  293.     stack[stack_now] = (char *) root;
  294. #ifdef SAVE_TRACE
  295.     save_trace("init_root", stack_now, (Node) stack[stack_now]);
  296. #endif
  297.  
  298.     while (stack_now) {
  299.         /*n frome stack;*/
  300.         n = (Node) stack[stack_now];
  301. #ifdef DEBUG
  302.         if (trapns>0 && N_SEQ(n) == trapns && N_UNIT(n) == trapnu) trapn(n);
  303. #endif
  304.         /* define SAVE_TRACE for exhaustive trace as write tree */
  305. #ifdef SAVE_TRACE
  306.         save_trace("process", stack_now, (Node) n);
  307. #endif
  308.         if (N_UNIT(n) == unit_now)  reach[(int)N_SEQ(n)] = '1';
  309.         stack_now--;
  310.         if (n == OPT_NODE) continue;
  311.         /*tree_node := [n, N_KIND(n)];*/
  312.         nk = N_KIND(n);
  313.         nodes[1] = nodes[2] = nodes[3] = nodes[4] = (Node)0;
  314.         if (N_AST1_DEFINED(nk)) nodes[1] = N_AST1(n);
  315.         if (N_AST2_DEFINED(nk)) nodes[2] = N_AST2(n);
  316.         if (N_AST3_DEFINED(nk)) nodes[3] = N_AST3(n);
  317.         if (N_AST4_DEFINED(nk)) nodes[4] = N_AST4(n);
  318.         for (i = 1; i <= 4; i++) {
  319.             nod = nodes[i];
  320.             /*tree_node with:= #a;*/
  321.             if (nod == (Node)0) continue;
  322.             /*if (tree_node /=OPT_NODE) stack with:= a(#a-i+1);*/
  323.             if (nod == OPT_NODE) continue;
  324.             if (stack_now == stack_max) { /* expand stack */
  325.                 stack[0] = (char *) stack_now;
  326.                 stack = tup_exp(stack, (unsigned) (stack_now+STACK_INC));
  327.                 stack[0] = (char *) stack_now;
  328.                 stack_max += STACK_INC;
  329.             }
  330.             /* add node to stack */
  331.             /*tree_node with:= a(i);*/
  332.             stack[++stack_now] = (char *) nod;
  333. #ifdef SAVE_TRACE
  334.             save_trace("stack_ast", stack_now, nod);
  335. #endif
  336.         }
  337.         if (N_LIST_DEFINED(nk))
  338.             a = N_LIST(n);
  339.         else
  340.             a = (Tuple)0;
  341.         if (a != (Tuple)0 ) {
  342.             /*tree_node with:= #a;*/
  343.             na = tup_size(a);
  344.             /*(for i in [1..#a])*/
  345.             for (i = 1; i <= na; i++) {
  346.                 /*tree_node with:= a(i);*/
  347.                 nod = (Node) a[i]; 
  348.                 if (N_UNIT(nod) == unit_now) reach[(int)N_SEQ(nod)] = '1';
  349.                 /*stack with:= a(#a-i+1);*/
  350.                 if (stack_now == stack_max) {
  351.                     stack[0] = (char *) stack_now;
  352.                     stack = tup_exp(stack, (unsigned) stack_now+STACK_INC);
  353.                     stack[0] = (char *) stack_now;
  354.                     stack_max += STACK_INC;
  355.                 }
  356.                 stack[++stack_now] = (char *) nod;
  357. #ifdef SAVE_TRACE
  358.                 save_trace("stack_list", stack_now, nod);
  359. #endif
  360.             }
  361.         }
  362.     }
  363.     renumber_nodes(reach);
  364.     write_tre(uindex, N_SEQ(root), reach);
  365.     efreet(reach, "reach");
  366.     tup_free(stack);
  367. }
  368.  
  369. static void renumber_nodes(char *reach)            /*;renumber_nodes*/
  370. {
  371.     /* This procedure renumbers the nodes so that the nodes which are live
  372.      * (not dead) and need to be written out in the tree (trc) file are 
  373.      * contigous and the seq_node array is therefore dense. This reduces 
  374.      * the size of seq_node necessary for separate compilation and in the 
  375.      * code generator phase. In addition the offset table written in the trc 
  376.      * file will also be reduced with this compressed version. The scheme 
  377.      * is relatively simple in that all nodes that are unreachable are 
  378.      * exchanged with positions that are reachable which appear later in 
  379.      * the list (tuple). Only one pass over the nodes is necessary using this
  380.      * method, so it is quite efficient.  
  381.      * Note that seq_node_n is changed in this procedure.
  382.      */
  383.  
  384.     int     i, j;
  385.     int        reachable_node_found;
  386.     Node    nod, unreachable_node;
  387.  
  388.     j = seq_node_n;
  389.     for (i = 1; i <= j; i++) {
  390.         /* First search rightward for a node which is unreachable (where reach 
  391.          * is 0 for that element). This will then be exchanged with a node 
  392.          * which is reachable which is found by searching the list leftward.
  393.          * Ultimately the left and right pointers (i & j) will converge.
  394.          */
  395.         if (reach[i] == '1') continue;
  396.         reachable_node_found = 0;
  397.  
  398.         /* Search for reachable node from the right */
  399.         for (; j > i; j--) {
  400.             if (reach[j] == '1') {
  401.                 reachable_node_found = 1;
  402.                 break;
  403.             }
  404.         }
  405.         /* If there is no reachable node found any more we are done with the
  406.          * compression.
  407.          */
  408.         if (!reachable_node_found)  break;
  409.         nod = (Node) seq_node[j];
  410.         unreachable_node = (Node) seq_node[i];
  411.         /* Exchange positions of the two nodes and set their seqeunce number 
  412.          * to the respective new position numbers.
  413.          * Currently the node in seq_node[i] cannot be wiped out since it is
  414.          * still needed because of save_package_instance.
  415.          */
  416.         seq_node[i] = (char *) nod;
  417.         seq_node[j] = (char *) unreachable_node;
  418.         N_SEQ(nod) = i;
  419.         N_SEQ(unreachable_node) = j;
  420.         reach[i] = '1';
  421.         reach[j] = '0';
  422.     }
  423.     seq_node_n = i - 1;
  424. }
  425.  
  426. #ifdef SAVE_TRACE
  427. void save_trace(char *s, int n, Node nod)
  428. {
  429.     if (save_trace_opt == 0) return;
  430.     printf("%11s %d\n", s, n);
  431.     zpnod(nod);
  432. }
  433. #endif
  434. void save_trace_init()
  435. {
  436.     save_trace_opt++;
  437. }
  438.  
  439. Tuple unit_symbtab(Symbol unit_unam, char unit_typ)            /*;unit_symbtab*/
  440. {
  441.     /* Collect symbol table entries for all entities declared in a compila-
  442.      * tion     unit, including inner units  and blocks. We iterate  over  the
  443.      * symbol table, and save all objects that are declared in the unit and
  444.      * in inner scopes.  For non-generic package bodies, we omit the  decla-
  445.      * rations that     appear in the visible part, and are already saved with 
  446.      * the package spec.
  447.      */
  448.  
  449.     Tuple    symb_map;
  450.     Tuple    ignore;
  451.     Set        scopes, seen;
  452.     Symbol    u_name, sc, sym;
  453.     char    *id;
  454.     Fordeclared fd1;
  455.     Forprivate_decls fp1;
  456.     Private_declarations pd;
  457.     int        ignore_n;
  458.  
  459.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : unit_symbtab:");
  460.  
  461.     unit_nodes = tup_new(0);
  462.     if (errors) return unit_nodes;
  463.  
  464.     symb_map = tup_new(0);
  465.     ignore = tup_new(0); 
  466.     ignore_n = 0;
  467.     if (NATURE(unit_unam) == na_package && unit_typ == 'u') {
  468.         ignore = tup_exp(ignore, 10);
  469.         ignore_n = 0;
  470.         FORDECLARED(id, u_name, DECLARED(unit_unam), fd1);
  471.             if (IS_VISIBLE(fd1)) {
  472.                 if (tup_mem((char *) u_name, ignore)) continue;
  473.                 if (ignore_n>=tup_size(ignore)) {
  474.                     ignore = tup_exp(ignore, (unsigned) (ignore_n+10));
  475.                 }
  476.                 ignore_n += 1;
  477.                 ignore[ignore_n] = (char *) u_name;
  478.             }
  479.         ENDFORDECLARED(fd1);
  480.     }
  481.  
  482.     /* first, collect the nodes referenced in the current unit Symbtab record.
  483.      * then, iterate through it's declared map to get declarations in inner
  484.      * scopes.
  485.      */
  486.     collect_unit_nodes(unit_unam);
  487.  
  488.     ignore[0] = (char *) ignore_n;
  489.     seen = set_new1((char *) unit_unam);
  490.     scopes = set_copy(seen);
  491.  
  492.     while (set_size(scopes) != 0) {
  493.         sc = (Symbol) set_from(scopes);
  494.         FORDECLARED(id, u_name, DECLARED(sc), fd1);
  495.             if (! tup_mem((char *)u_name, ignore) ) {    /* save its info. */
  496.                 /* Collect the AST nodes that appear in SYMBTAB, and may thus*/
  497.                 /* be needed for separate compilation and code generation.*/
  498.                 collect_unit_nodes(u_name);
  499.                 /*symb_map(u_name) := SYMBTABF(u_name);*/
  500.                 symb_map = sym_save(symb_map, u_name, unit_typ);
  501.             }
  502.             /* note that na_enum symbols have their literal map stored in the
  503.              * DECLARED field and so should be skipped in next test
  504.              * IS THIS STILL TRUE???? 
  505.              */
  506.             if (NATURE(u_name) == na_enum) continue;
  507.  
  508.             if (DECLARED(u_name) != (Declaredmap)0 
  509.               && (!set_mem((char *)u_name, seen ) )){
  510.                 /* collect local declarations of inner scope.*/
  511.                 scopes = set_with(scopes, (char *) u_name);
  512.                 seen = set_with(seen, (char *) u_name);
  513.             }
  514.         ENDFORDECLARED(fd1);
  515.  
  516.         if (NATURE(sc) == na_package || NATURE(sc) == na_package_spec
  517.           || NATURE(sc) == na_generic_package
  518.           || NATURE(sc) == na_generic_package_spec) {
  519.             /* Collect and save nodes attatched to private_decls field */
  520.             pd = (Private_declarations) private_decls(sc);
  521.             FORPRIVATE_DECLS(sym, u_name, pd, fp1);
  522.                 collect_unit_nodes(u_name);
  523.             ENDFORPRIVATE_DECLS(fp1);
  524.         }
  525.     }
  526.     /* We include in symb_map the information for the unit itself, which is
  527.      * declared in STANDARD.
  528.      */
  529.     /* TBSL: get rid of this KLUDGE
  530.      * for generic subprograms, save symbol regardless of unit, so that the
  531.      * unit name of body is retrievable after being overwritten by spec
  532.      */
  533.     if (NATURE(unit_unam) == na_generic_procedure
  534.       || NATURE(unit_unam) == na_generic_function 
  535.       || NATURE(unit_unam) == na_generic_package)
  536.         symb_map = sym_save(symb_map, unit_unam, 's');
  537.     else 
  538.         symb_map = sym_save(symb_map, unit_unam, unit_typ);
  539.     set_free(seen); 
  540.     set_free(scopes);
  541.     /* replace symbol pointers to copy of symbol table entries */
  542.     tup_free(ignore);
  543.     return symb_map;
  544. }
  545.  
  546. static void collect_unit_nodes(Symbol u_name)            /*;collect_unit_nodes*/
  547. {
  548.     /* Collect the AST nodes that appear in SYMBTAB, and may thus*/
  549.     /* be needed for separate compilation and code generation.*/
  550.  
  551.     int     nat, i, size;
  552.     Symbol     typ;
  553.     Tuple    sig, discr_map, gen_list, tup;
  554.     Fortup     ft1;
  555.  
  556.     typ = TYPE_OF(u_name);
  557.     nat = NATURE(u_name);
  558.     if (typ == symbol_incomplete || typ == symbol_private 
  559.       || typ == symbol_limited_private)
  560.         nat = na_record; /* signature has form of record signature */
  561.  
  562.     switch (nat) {
  563.     case na_constant:
  564.     case na_discriminant:
  565.     case na_in:
  566.         unit_nodes_add((Node) default_expr(u_name));
  567.         break;
  568.     case na_type:
  569.         sig = SIGNATURE(u_name);
  570.         if (sig == (Tuple)0)
  571.             chaos("unit_symbtab subtype - no signature");
  572.         if ((int) sig[1] == CONSTRAINT_DELTA) {
  573.             unit_nodes_add((Node) numeric_constraint_low(sig));
  574.             unit_nodes_add((Node) numeric_constraint_high(sig));
  575.             unit_nodes_add((Node) numeric_constraint_delta(sig));
  576.             unit_nodes_add((Node) numeric_constraint_small(sig));
  577.         }
  578.         break;
  579.     case na_subtype:
  580.         sig = SIGNATURE(u_name);
  581.         if (sig == (Tuple)0)
  582.             chaos("unit_symbtab subtype - no signature");
  583.         if (is_scalar_type(u_name))     {
  584.             unit_nodes_add((Node) numeric_constraint_low(sig));
  585.             unit_nodes_add((Node) numeric_constraint_high(sig));
  586.             if ((int) sig[1] == CONSTRAINT_DELTA) {
  587.                 unit_nodes_add( (Node) numeric_constraint_delta(sig));
  588.                 unit_nodes_add( (Node) numeric_constraint_small(sig));
  589.             }
  590.             else if ((int) sig[1] == CONSTRAINT_DIGITS) {
  591.                 unit_nodes_add( (Node) numeric_constraint_digits(sig));
  592.             }
  593.         }
  594.         else if (is_record(u_name)) {
  595.             discr_map = (Tuple) sig[2];
  596.             size = tup_size(discr_map);
  597.             for (i = 1; i <= size; i+=2)
  598.                 unit_nodes_add((Node) discr_map[i+1]);
  599.         }
  600.         break;
  601.     case na_enum:
  602.         sig = SIGNATURE(u_name);
  603.         if (sig == (Tuple)0) chaos("unit_symbtab enum - no signature");
  604.         unit_nodes_add((Node) numeric_constraint_low(sig));
  605.         unit_nodes_add((Node) numeric_constraint_high(sig));
  606.         break;
  607.     case na_record:
  608.         unit_nodes_add((Node) invariant_part(u_name));
  609.         unit_nodes_add((Node) variant_part(u_name));
  610.         unit_nodes_add((Node) discr_decl_tree(u_name));
  611.         break;
  612.     case na_procedure_spec:
  613.     case na_function_spec:
  614.     case na_entry:
  615.     case na_entry_family:
  616.     case na_generic_procedure_spec:
  617.     case na_generic_function_spec:
  618.         unit_nodes_add((Node) formal_decl_tree(u_name));
  619.         break;
  620.         /* 
  621.          * Clear out the formal_decl_tree fields of procedure or 
  622.          * function symbols since these are not needed for 
  623.          * conformance checks (only na_procedure_spec or 
  624.          * na_function_spec symbols need this entry).
  625.          */
  626.     case na_procedure:
  627.     case na_function:
  628.         formal_decl_tree(u_name) = (Symbol)0;
  629.         break;
  630.         /*
  631.          * the nodes of generic packages(specs and bodies) or nodes of generic
  632.          * subprograms bodies are not automatically read in. They are brought 
  633.          * in explicitly upon instantiation. Default values for generic para-
  634.          * meters however must be read in for instantiation. The generic_list
  635.          * is a tuple of pairs [name, initial value] which we unpack here.
  636.          */
  637.     case na_generic_package_spec:
  638.     case na_generic_package:
  639.     case na_generic_function:
  640.     case na_generic_procedure:
  641.         sig = SIGNATURE(u_name);
  642.         gen_list = (Tuple)sig[1];
  643.         FORTUP(tup=(Tuple), gen_list, ft1)
  644.             unit_nodes_add((Node)tup[2]);
  645.         ENDFORTUP(ft1);
  646.         break;
  647.     }
  648. }
  649.  
  650. void save_subprog_info(Symbol unit_unam)                /*;save_subprog_info*/
  651. {
  652.     /* Save declarations for a subprogram specification or body which is a
  653.      * compilation unit.
  654.      */
  655.  
  656.     int    uindex;
  657.     Unitdecl ud;
  658.  
  659.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  save_subprog_info");
  660.  
  661.     if (IS_COMP_UNIT){
  662.         if (unit_unam == (Symbol)0) {
  663. #ifdef ERRNUM
  664.             errmsgn(11, 10, (Node)0);
  665. #else
  666.             errmsg("Invalid compilation unit", "none", (Node)0);
  667. #endif
  668.             return;
  669.         }
  670.         /* get unit number (assign new one if needed) */
  671.         uindex = unit_number(unit_name);
  672.  
  673.         /* For subprograms, UNIT_DECL has 4 fields:
  674.          *    1.  unique name of subprogram
  675.          *    2.  symbol table entries
  676.          *    3.  declared maps for subprogram's scope
  677.          *      ( for possible late instantiations)
  678.          *    4.  context (supplied in compunit)
  679.          *
  680.          * case nature(unit_unam) of
  681.          *  (na_procedure_spec, na_function_spec,
  682.          *  na_generic_procedure_spec, na_generic_function_spec):
  683.          *   decmap := {[unit_unam, declared(unit_unam)]};
  684.          *
  685.          *  TBSL for generics
  686.          *  (na_generic_procedure, na_generic_function):
  687.          *  decmap := generic_declarations();
  688.          *  decmap(unit_unam) := declared(unit_unam);
  689.          *
  690.          * else
  691.          *  TBSL for generics
  692.          *  decmap := generic_declarations();
  693.          * end case;
  694.          *
  695.          * UNIT_DECL(unit_name) :=
  696.          *   [unit_unam, unit_symbtab(unit_unam), decmap, [], {}];
  697.          */
  698.         ud = unit_decl_get(unit_name);
  699.         if (ud == (Unitdecl)0) ud = unit_decl_new();
  700.         ud->ud_unam = unit_unam;
  701.         NEEDNAME(unit_unam) = TRUE;
  702.         ud->ud_useq =  S_SEQ(unit_unam);
  703.         ud->ud_unit =  S_UNIT(unit_unam);
  704.         ud->ud_symbols = unit_symbtab(unit_unam, 'u');
  705.         if (DECLARED(unit_unam) == (Declaredmap)0) {
  706.             ud->ud_decscopes = (Tuple) 0;
  707.             ud->ud_decmaps     = (Tuple) 0;
  708.         }
  709.         else {
  710.             ud->ud_decscopes = tup_new1((char *) unit_unam);
  711.             ud->ud_decmaps = tup_new1(
  712.               (char *) dcl_copy(DECLARED(unit_unam)));
  713.         }
  714.         unit_decl_put(unit_name, ud);
  715.     }
  716. }
  717.  
  718. static void generic_declarations(Symbol unit_unam, Unitdecl ud)
  719.                                                     /*;generic_declarations*/
  720. {
  721.     /* This procedure collects the contents of declared maps within generic
  722.      *  subunits, for possible subsequent late instantiations.
  723.      */
  724.  
  725.     Tuple    decscopes, decmaps;
  726.     Set    decl_scopes, scopes, seen;
  727.     Symbol u_name, sc;
  728.     char    *id;
  729.     Fordeclared fd1;
  730.     decscopes = tup_new(0);
  731.     decmaps = tup_new(0);
  732.  
  733.     if (NATURE(unit_unam) == na_generic_package)
  734.         decl_scopes = tup_new1((char *) unit_unam);
  735.     else
  736.         decl_scopes = tup_new(0);
  737.  
  738.     /* In SETL want to iterate over declared - i.e., we need to  know domain
  739.      * of declared. We take this by looking at all symbols defined in current
  740.      * unit for which declared field defined. This includes some extra symbols,
  741.      * I think due to private decls, but these extra maps seem harmless.
  742.      */
  743.     scopes = set_new1((char *)unit_unam);
  744.     seen = set_new(0);
  745.     while (set_size(scopes) != 0) {
  746.         sc = (Symbol) set_from(scopes);
  747.         seen = set_with(seen, (char *)sc);
  748.         if (DECLARED(sc) != (Declaredmap)0) {
  749.             FORDECLARED(id, u_name, DECLARED(sc), fd1);
  750.             if (DECLARED(u_name) != (Declaredmap)0 
  751.               &&(!set_mem((char *)u_name, seen))) {
  752.                 /* collect local declarations of inner scope.*/
  753.                 if (NATURE(u_name) == na_generic_procedure
  754.                   || NATURE(u_name) == na_generic_function
  755.                   || NATURE(u_name) == na_generic_package)
  756.                     decl_scopes = set_with(decl_scopes, (char *)u_name);
  757.                 else if (NATURE(u_name) == na_package)
  758.                     scopes = set_with(scopes, (char *) u_name);
  759.             }
  760.             ENDFORDECLARED(fd1);
  761.         }
  762.     }
  763.  
  764.     seen = set_new(0);
  765.  
  766.     while (set_size(decl_scopes) != 0) {
  767.         sc = (Symbol) set_from(decl_scopes);
  768.         seen = set_with(seen, (char *)sc);
  769.         decscopes = tup_with(decscopes, (char *) sc);
  770.         decmaps = tup_with(decmaps, (char *) dcl_copy(DECLARED(sc)));
  771.         FORDECLARED(id, u_name, DECLARED(sc), fd1);
  772.             if (DECLARED(u_name) != (Declaredmap)0 
  773.               &&(!set_mem((char *)u_name, seen)))
  774.                 /* collect local declarations of inner scope.*/
  775.                 decl_scopes = set_with(decl_scopes, (char *) u_name);
  776.         ENDFORDECLARED(fd1);
  777.     }
  778.  
  779.     ud->ud_decscopes = decscopes;
  780.     ud->ud_decmaps = decmaps;
  781.     set_free(seen); 
  782.     set_free(scopes);
  783. }
  784.  
  785. void save_spec_info(Symbol unit_unam, Tuple old_vis)        /*;save_spec_info*/
  786. {
  787.     /* Build UNIT_DECL for a package spec. that is a compilation unit.*/
  788.  
  789.     Symbol    sn;
  790.     int    i, uindex;
  791.     Tuple    decscopes, decmaps, decl_scopes;
  792.     Unitdecl ud;
  793.  
  794.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : save_spec_info");
  795.  
  796.     /* This was here as early as 1983, and now not only seems useless, but
  797.      * is WRONG !!!
  798.      * At end of module_body, we iterate over all inner scopes, and the presence
  799.      * of generic inside scope of instance results in looping.
  800.     if (NATURE(unit_unam) == na_generic_package_spec) {
  801.      * save name within its own declarations, to simplify retrieval at
  802.      * instantiation time.
  803.         dcl_put(DECLARED(unit_unam), original_name(unit_unam), unit_unam);
  804.     }
  805.      */
  806.     /*
  807.      * For package specifications, UNIT_DECL has 6 fields.
  808.      *    1. unique name of compilation unit
  809.      *    2. symbol table entries
  810.      *    3. declared maps for program defined scopes
  811.      *    4. vis_mods
  812.      *    5. difference between declared and visible
  813.      *    6. context (supplied in comp_unit)
  814.      */
  815.     decscopes = tup_new(0);
  816.     decmaps = tup_new(0);
  817.     /* In SETL want to iterate over declared - i.e., we need to  know domain
  818.      * of declared. We take this by looking at all symbols defined in current
  819.      * unit for which declared field defined. This includes some extra symbols,
  820.      * I think due to private decls, but these extra maps seem harmless.
  821.      */
  822.     decl_scopes = tup_new(0);
  823.     for (i = 1; i <= seq_symbol_n; i++)
  824.         if (DECLARED((Symbol)seq_symbol[i]) != (Declaredmap)0)
  825.             decl_scopes = tup_with(decl_scopes, seq_symbol[i]);
  826.     for (i = 1; i <= tup_size(decl_scopes); i++){
  827.         sn = (Symbol) decl_scopes[i];
  828.         decscopes = tup_with(decscopes, (char *) sn);
  829.         decmaps = tup_with(decmaps, (char *) dcl_copy(DECLARED(sn)));
  830.     }
  831.     /*decmap := {[sn, dsn] : dsn = declared(sn) | sn notin p_s};
  832.      *
  833.      * Notvis keeps track of things declared but not visible
  834.      */
  835. #ifdef TBSL
  836. -- note change in def of notvis 5-jan-85:
  837.     only define notvis
  838.         -- is vis is not om.
  839. notvis :
  840.         = {
  841.     };
  842.     (for [sn, dsn] in decmap | visible(sn) /= om)
  843.         notvis(sn) :
  844.         = {
  845. dec: 
  846.             dec in dsn | dec notin visible(sn)        };
  847.     end for;
  848.     notvis = tup_new(0);
  849. #endif
  850.     /* UNIT_DECL(unit_name) :=
  851.      *   [unit_unam, unit_symbtab(unit_unam), decmap, old_vis, notvis];
  852.      * In C version have different format .
  853.      */
  854.  
  855.     if (!unit_numbered(unit_name)) uindex = unit_number(unit_name);
  856.     ud = unit_decl_get(unit_name);
  857.     if (ud == (Unitdecl)0) ud = unit_decl_new();
  858.     ud->ud_unam =    unit_unam;
  859.     NEEDNAME(unit_unam) = TRUE;
  860.     ud->ud_useq = S_SEQ(unit_unam);
  861.     ud->ud_unit = S_UNIT(unit_unam);
  862.     ud->ud_symbols = unit_symbtab(unit_unam, 'u');
  863.     ud->ud_decscopes = decscopes;
  864.     ud->ud_oldvis = tup_copy(old_vis);
  865.     ud->ud_decmaps = decmaps;
  866.     unit_decl_put(unit_name, ud);
  867. }
  868.  
  869. void save_body_info(Symbol nam)                    /*;save_body_info*/
  870. {
  871.     /* For a package body, only the symbol table information needs to be
  872.      * saved, for purposes of generic instantiation. Visibility information
  873.      * is not kept.
  874.      */
  875.  
  876.     int        uindex;
  877.     Unitdecl    ud;
  878.  
  879.     if (cdebug2 > 3) TO_ERRFILE("AT PROC: save_body_info");
  880.  
  881.     if (IS_COMP_UNIT) {
  882.         /*
  883.          * UNIT_DECL(unit_name) := [nam, unit_symbtab(nam), 
  884.          *                generic_declarations(), [], {}];
  885.          */
  886.         uindex = unit_number(unit_name);
  887.         ud = unit_decl_get(unit_name);
  888.         if (ud == (Unitdecl)0) ud = unit_decl_new();
  889.         ud->ud_unam =  nam;
  890.         NEEDNAME(nam) = TRUE;
  891.         ud->ud_useq =  S_SEQ(nam);
  892.         ud->ud_unit =  S_UNIT(nam);
  893.         ud->ud_symbols  =  unit_symbtab(nam, 'u');
  894.         generic_declarations(nam, ud);
  895.         unit_decl_put(unit_name, ud);
  896.     }
  897. }
  898.  
  899. static void save_proper_body_info(Node node)        /*;save_proper_body_info*/
  900. {
  901.     Node    proper_node, spec, name_node;
  902.     Symbol    unit_unam;
  903.     Unitdecl    ud;
  904.  
  905.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  save_proper_body_info");
  906.  
  907.     proper_node = N_AST2(node);
  908.     if (N_KIND(proper_node) == as_generic_procedure
  909.       || N_KIND(proper_node) == as_generic_function) {
  910.         spec = N_AST1(proper_node);
  911.         name_node = N_AST1(spec);
  912.     }
  913.     /* For subprogram proper bodies the unique name is stored in the
  914.      * proper_node itself.
  915.      */
  916.     else if (N_KIND(proper_node) == as_subprogram_tr) {
  917.         name_node = proper_node;
  918.     }
  919.     else 
  920.         name_node = N_AST1(proper_node);
  921.  
  922.     unit_unam = N_UNQ(name_node);
  923.  
  924.     /* UNIT_DECL(unit_name) :=
  925.      *    [unit_unam, unit_symbtab(unit_unam), generic_declarations(), [], {}];
  926.      */
  927.  
  928.     ud = unit_decl_get(unit_name);
  929.     if (ud == (Unitdecl)0) ud = unit_decl_new();
  930.     ud->ud_unam = unit_unam;
  931.     NEEDNAME(unit_unam) = TRUE;
  932.     ud->ud_useq = S_SEQ(unit_unam);
  933.     ud->ud_unit = S_UNIT(unit_unam);
  934.     ud->ud_symbols = unit_symbtab(unit_unam, 'u');
  935.  
  936. #ifdef TBSL
  937.     handle generic_declarations
  938. #endif
  939.  
  940.     unit_decl_put(unit_name, ud);
  941. }
  942.  
  943. static void save_package_instance_unit(Node node)/*;save_package_instance_unit*/
  944. {
  945.     /* If a unit is a package instance, it is necessary to construct two 
  946.      * units, one for the spec and one for the body of the instance.
  947.      */
  948.  
  949.     Node    context_node, unit_body, spec_node, body_node, id_node, b_node;
  950.     char    *nam;
  951.     Symbol    unam;
  952.     Tuple    tup;
  953.     Unitdecl    ud;
  954.     int        saved_seq_node_n, i;
  955.  
  956.     context_node = N_AST1(node);
  957.     unit_body = N_AST2(node);
  958.  
  959.     /* The unit body is an insert node; unpack spec and body of instance.*/
  960.     tup = N_LIST(unit_body);
  961.     spec_node = (Node) tup[1];
  962.     id_node = N_AST1(spec_node);
  963.     body_node = N_AST1( unit_body);
  964.  
  965.     N_AST1(node) = context_node;
  966.     N_AST2(node) = spec_node;
  967.     unit_name[0] = 's'; /* set to spec */
  968.     unit_name[1] = 'p';
  969.  
  970.     /* Build a node for the package instance, and rebuild compilation info.
  971.      * for it. Its UNIT_DECL need not contain symbol table info, which is
  972.      * emitted with the spec, and always retrieved at the same time.
  973.      * TBSL: what if this is a delayed instance?
  974.      */
  975.     nam = unit_name_name(unit_name);
  976.     b_node = node_new(as_unit);
  977.     N_AST1(b_node) = context_node;
  978.     N_AST2(b_node) = body_node;
  979.  
  980.     /* Since nodes for the spec and body were created at the same time they
  981.      * both have the same unit number. 
  982.      * After the spec is written change the unit field of all the body nodes 
  983.      * to reflect its unit.
  984.      */
  985.     unam = N_UNQ(id_node);
  986.     /* Set the nature of the symbol to be as a package spec so that the private 
  987.      * declarations (OVERLOADS field) is set upon reading the spec of the 
  988.      * instantiated package. Reset to package after the unit is written.
  989.      */
  990.     NATURE(unam) = na_package_spec;
  991.     /* Save the old value of seq_node_n since this will be changed when
  992.      * renumber_nodes is called by save_tree and sets seq_node_n to the 
  993.      * number of live and useful nodes. However all the nodes in seq_node need
  994.      * to be accessable for working with the package body nodes, so we will
  995.      * have to reset seq_node_n to the saved value. This is basically due to
  996.      * the artifact of how instantiated package body are handled.
  997.      */
  998.     saved_seq_node_n = seq_node_n;
  999.     save_comp_info(node);
  1000.     seq_node_n = saved_seq_node_n;
  1001.     OVERLOADS(unam) = 0;
  1002.     NATURE(unam) = na_package;
  1003.  
  1004.     all_vis = tup_with(all_vis, unit_name);        /* body depends on spec.*/
  1005.     unit_name = strjoin("bo", nam);
  1006.     unit_number_now = unit_number(unit_name);
  1007.     new_unit_numbers(b_node, unit_number_now);
  1008.     /* Set the number of symbols to be 0 so that the unit number of the symbol
  1009.      * for the package is not reset to be the unit number for the body.
  1010.      */
  1011.     seq_symbol_n = 0;
  1012.     unit_nodes = tup_new(0);
  1013.     unam = N_UNQ(id_node);
  1014.     ud = unit_decl_new();
  1015.     ud->ud_unam = unam;
  1016.     ud->ud_useq = S_SEQ(unam);
  1017.     ud->ud_unit = S_UNIT(unam);
  1018.     ud->ud_symbols = tup_new(0);
  1019.     unit_decl_put(unit_name, ud);
  1020.  
  1021.     /*UNIT_DECL(unit_name) := [nam, {}, {}, [], {}];*/
  1022.     /* TBSL: note that now setting five components    ds 7 dec 84 */
  1023.  
  1024.     save_comp_info(b_node);
  1025. }
  1026.  
  1027. static void save_subprogram_instance_unit(Node node)
  1028.   /*; save_subprogram_instance_unit */
  1029. {
  1030.     /* The instantiation code (renamings of formals by actuals, bounds checks)
  1031.      * are elaborated before the body of the instance. If the instance is a
  1032.      * unit, the instantiation code must in fact be placed in a anonymous unit
  1033.      * on which the instantiation depends.
  1034.      * For now, we place the renamings in the dclarative part of the procedure,
  1035.      * which is inefficient but harmless. 
  1036.      * TBSL: construction of anonymous unit with the rest
  1037.      */
  1038.  
  1039.     Tuple  i_code , i_decls, i_checks, ntup;
  1040.     Node   instance, decl_node, n, ins_node, context_node, b_node;
  1041.     int    i, k;
  1042.  
  1043.     context_node = N_AST1(node);
  1044.     ins_node = N_AST2(node);            /* insert node */
  1045.     i_code = N_LIST(ins_node);            /* instantiation code */
  1046.     instance = N_AST1(ins_node);        /* subprogram instance*/
  1047.     N_AST2(node) = instance;
  1048.     decl_node = N_AST2(instance);
  1049.     i_decls = tup_new(0);
  1050.     i_checks = tup_new(0);
  1051.     for ( i = 1; i <= tup_size(i_code); i++) {
  1052.         n = (Node)tup_fromb(i_code);
  1053.         k = N_KIND(n);
  1054.         if (k == as_raise || k == as_check_bounds || k == as_check_discr)
  1055.             i_checks = tup_with(i_checks, (char *) n);
  1056.         else
  1057.             i_decls  = tup_with(i_decls, (char *) n);
  1058.     }
  1059.  
  1060.     ntup = tup_add(i_decls, N_LIST(decl_node));
  1061.     tup_free(N_LIST(decl_node));
  1062.     N_LIST(decl_node) = ntup;
  1063.  
  1064.     b_node = node_new(as_unit);
  1065.     N_AST1(b_node) = context_node;
  1066.     N_AST2(b_node) = instance;
  1067.     save_comp_info(b_node);
  1068.  
  1069.     if (tup_size(i_checks) > 0) 
  1070.         chaos("subprogram_instance_unit: checks left over");
  1071. }
  1072.  
  1073. static void establish_context(Node node)    /*;establish_context*/
  1074. {
  1075.     char    *name, *nam;
  1076.     Fortup    ft1, ft2, ft3;
  1077.     Node    un_node, clause_node, uw_node, unit_node;
  1078.     Node    context_node, spec, name_node;
  1079.     int    kind, i, nk;
  1080.     Tuple    tupn, tup, use_nodes, with_tup;
  1081.     char    *spec_name;
  1082.     Tuple    elaborate_list, with_list, nam_list, inherited_context = (Tuple)0;
  1083.     Unitdecl spec_decl;
  1084.  
  1085.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  establish_context(name);");
  1086.  
  1087.     context_node = N_AST1(node);
  1088.     unit_node = N_AST2(node);
  1089.  
  1090.     /* Flatten with- and use-clauses from context node.*/
  1091.  
  1092.     context = tup_new(0);
  1093.     with_list = N_LIST(context_node);
  1094.     elaborate_list = tup_new(0);
  1095.     /* NOTE that ELABORATE pragmas can only appear immediately after a
  1096.      * context_clause.  The necessary checks to insure that this condition
  1097.      * is met have not been made.
  1098.      */
  1099.     use_nodes = tup_new(0);
  1100.     with_tup = tup_new(0);
  1101.     FORTUP(clause_node=(Node), with_list, ft1);
  1102.         FORTUP(uw_node=(Node), N_LIST(clause_node), ft2);
  1103.             kind = N_KIND(uw_node);
  1104.             if (kind == as_with || kind == as_use) {
  1105.                 tupn = tup_new(tup_size(N_LIST(uw_node)));
  1106.                 FORTUPI(un_node=(Node), N_LIST(uw_node), i, ft3);
  1107.                     tupn[i] = N_VAL(un_node);
  1108.                 ENDFORTUP(ft3);
  1109.                 tup = tup_new(2);
  1110.                 tup[1] = (char *) kind;
  1111.                 tup[2] = (char *) tupn;
  1112.                 context = tup_with(context, (char *) tup);
  1113.                 if (kind == as_use) {
  1114.                     /* save nodes for subsequent call to resolve_use_clause */
  1115.                     use_nodes = tup_with(use_nodes, (char *)uw_node);
  1116.                     /* check that it appears in a previous with clause */
  1117.                     FORTUP(name = (char *), tupn, ft3);
  1118.                         if (!tup_memstr(name, with_tup))
  1119. #ifdef ERRNUM
  1120.                             str_errmsgn(12, name, 13, uw_node);
  1121. #else
  1122.                         errmsg_str("% does not appear in previous with clause",
  1123.                           name, "10.1.1", uw_node);
  1124. #endif
  1125.                     ENDFORTUP(ft3);
  1126.                 }
  1127.                 else {
  1128.                     with_tup = tup_add(with_tup, tupn);
  1129.                 }
  1130.             }
  1131.             else {
  1132.                 elaborate_list = tup_with(elaborate_list, (char *) uw_node);
  1133.             }
  1134.         ENDFORTUP(ft2);
  1135.     ENDFORTUP(ft1);
  1136.  
  1137.     /* For bodies and proper bodies, collect any context specification
  1138.      * inherited from parent unit or from spec.
  1139.      */
  1140.     nk = N_KIND(unit_node);
  1141.     if (nk == as_separate) {
  1142.         inherited_context = check_separate(unit_node);
  1143.         if (inherited_context == (Tuple)0) {
  1144.             context = (Tuple) 0; /* indicates error */
  1145.             return;
  1146.         }
  1147.     }
  1148.     else if (nk == as_package_body) {
  1149.         name_node = N_AST1(unit_node);
  1150.         name = N_VAL(name_node);
  1151.         current_node = name_node;
  1152.         get_specs(name);
  1153.         all_vis = tup_with(all_vis, strjoin("sp", name));
  1154.         /* all_vis with:= ['spec', name]; */
  1155.         spec_decl = unit_decl_get(strjoin("sp", name));
  1156.         if (spec_decl != (Unitdecl)0)
  1157.             inherited_context = spec_decl->ud_context;
  1158.     }
  1159.     else if (nk == as_subprogram) {
  1160.         /* may have been subprogram spec.*/
  1161.         spec = N_AST1(unit_node);
  1162.         name_node = N_AST1(spec);
  1163.         name = N_VAL(name_node);
  1164.         spec_name = strjoin("ss", name);
  1165.         if (retrieve(spec_name) )
  1166.             all_vis = tup_with(all_vis, spec_name);
  1167.  
  1168.         spec_decl  = unit_decl_get(spec_name);
  1169.         if (spec_decl != (Unitdecl)0)
  1170.             inherited_context =  spec_decl->ud_context;
  1171.     }
  1172.  
  1173.     if (inherited_context == (Tuple) 0)
  1174.         /* this may occur if there were errors in previous units */
  1175.         inherited_context = tup_new(0);
  1176.  
  1177.     /* process inherited context specification */
  1178.     FORTUP(tup=(Tuple), inherited_context, ft1);
  1179.         kind = (int) tup[1];
  1180.         nam_list = (Tuple) tup[2];
  1181.  
  1182.         if (kind == as_with)
  1183.             with_clause(nam_list, current_node);
  1184.         else if (kind == as_use) {
  1185.             /* rebuild list of name nodes for use_clause */
  1186.             un_node = node_new(as_use);
  1187.             N_LIST(un_node) = tup_new(tup_size(nam_list));
  1188.             FORTUPI(nam = (char *), nam_list, i, ft2);
  1189.                 name_node = node_new(as_simple_name);
  1190.                 N_VAL(name_node) = nam;
  1191.                 N_LIST(un_node)[i] = (char *)name_node;
  1192.             ENDFORTUP(ft2);
  1193.             use_clause(un_node);
  1194.         }
  1195.     ENDFORTUP(ft1);
  1196.  
  1197.     /* Process the given context specification. */
  1198.     FORTUP(tup=(Tuple), context, ft1);
  1199.         kind = (int) tup[1];
  1200.         nam_list = (Tuple) tup[2];
  1201.  
  1202.         if (kind == as_with)
  1203.             with_clause(nam_list, context_node);
  1204.     ENDFORTUP(ft1);
  1205.  
  1206.     FORTUP(un_node=(Node), use_nodes, ft1);
  1207.         use_clause(un_node);
  1208.     ENDFORTUP(ft1);
  1209.     tup_free(use_nodes);
  1210.  
  1211.     FORTUP(name_node=(Node), elaborate_list, ft1);
  1212.         elaborate_pragma(name_node);
  1213.     ENDFORTUP(ft1);
  1214.  
  1215.     context = tup_add(inherited_context, context);
  1216. }
  1217.  
  1218. static void with_clause(Tuple nam_list, Node context_node)    /*;with_clause */
  1219. {
  1220.     char *nam, *unit;
  1221.     Fortup ft;
  1222.  
  1223.     FORTUP(nam=(char *), nam_list, ft);
  1224.         unit = get_unit(nam);
  1225.         if (strlen(unit) >0 )
  1226.             all_vis = tup_with(all_vis, unit);
  1227.         else {
  1228. #ifdef ERRNUM
  1229.             str_errmsgn(14, nam, 13, context_node);
  1230. #else
  1231.             errmsg_str("Unknown unit in with clause: %", nam, "10.1.1",
  1232.               context_node);
  1233. #endif
  1234.             all_vis = tup_with(all_vis, strjoin("sp", nam));
  1235.         }
  1236.     ENDFORTUP(ft);
  1237. }
  1238.  
  1239. static char *get_unit(char *nam)                /*;get_unit*/
  1240. {
  1241.     int    exists, i;
  1242.     char    *unit, *unit1, *unit2, *su, *body_name;
  1243.     Fortup    ft1;
  1244.     Node    id_node;
  1245.     Symbol    namsym, unit_unam, scope;
  1246.     Tuple    s_info, decscopes, decmaps;
  1247.     Unitdecl ud;
  1248.  
  1249.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  get_unit");
  1250.  
  1251.     exists = FALSE;
  1252.     for(i = 1; i <= unit_numbers; i++) {
  1253.         unit = pUnits[i]->libUnit;
  1254.         unit2 = unit_name_name(unit);
  1255.         unit1 = unit_name_type(unit);
  1256.         if (streq(unit2, nam)
  1257.           && (streq(unit1, "ss") || streq(unit1, "sp"))) {
  1258.             exists = TRUE;
  1259.             break;
  1260.         }
  1261.     }
  1262.     if (exists == FALSE) {
  1263.         su = strjoin("su", nam);
  1264.         for(i = 1; i <= unit_numbers; i++) {
  1265.             unit = pUnits[i]->libUnit;
  1266.             if (streq(su, unit)) {
  1267.                 exists = TRUE;
  1268.                 break;
  1269.             }
  1270.         }
  1271.     }
  1272.  
  1273.     if (exists) {
  1274.         if (cdebug2 > 3) TO_ERRFILE(strjoin("unit ", unit));
  1275.  
  1276.         if (streq(unit_name_type(unit), "sp")) {
  1277.             /* puts created symbol in standard0 scope*/
  1278.             unit_unam = get_specs(nam);
  1279.  
  1280.             namsym = dcl_get(DECLARED(symbol_standard0), nam);
  1281.             if (NATURE(unit_unam) != na_generic_package
  1282.               && NATURE(unit_unam) != na_generic_package_spec)
  1283.                 vis_mods =tup_with(vis_mods, (char *) namsym);
  1284.         }
  1285.         else {    /* unit is a subprogram */
  1286.             if (retrieve(unit) ) {
  1287.                 /*    [unit_unam, s_info, decmap] := UNIT_DECL(unit); */
  1288.                 ud = unit_decl_get(unit);
  1289.                 unit_unam  = ud->ud_unam;
  1290.                 s_info     = ud->ud_symbols;
  1291.                 decscopes  = ud->ud_decscopes;
  1292.                 decmaps    = ud->ud_decmaps;
  1293.  
  1294.                 /* Restore symbol table entries.*/
  1295.                 symtab_restore(s_info);
  1296.  
  1297.                 /* (for decls = decmap(scope)) 
  1298.                  *    declared(scope) := decls; 
  1299.                  * end; 
  1300.                  */
  1301.                 FORTUPI(scope=(Symbol), decscopes, i, ft1);
  1302.                     DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  1303.                 ENDFORTUP(ft1);
  1304.             }
  1305.             dcl_undef(DECLARED(symbol_standard0), nam);
  1306.             dcl_put(DECLARED(symbol_standard0), nam, unit_unam);
  1307.         }
  1308.         /* for generic specs retrieve body info */
  1309.         if (NATURE(unit_unam) == na_generic_package_spec) {
  1310.             body_name = strjoin("bo", nam);
  1311.             if (retrieve(body_name)) {
  1312.                 ud = unit_decl_get(body_name);
  1313.                 unit_unam = ud->ud_unam;
  1314.                 s_info = ud->ud_symbols;
  1315.                 decscopes = ud->ud_decscopes;
  1316.                 decmaps = ud->ud_decmaps;
  1317.  
  1318.                 /* SYMTAB restore */
  1319.                 symtab_restore(s_info);
  1320.  
  1321.                 FORTUPI(scope=(Symbol), decscopes, i, ft1);
  1322.                     if (decmaps[i] != (char *)0)
  1323.                         DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  1324.                 ENDFORTUP(ft1);
  1325.             }
  1326.         }
  1327.         else if (NATURE(unit_unam) == na_generic_procedure_spec
  1328.           || NATURE(unit_unam) == na_generic_function_spec) {
  1329.             body_name = strjoin("su", nam);
  1330.             /* CHECK HOW MUCH OF THIS IS NECESSARY !!! */
  1331.             if (retrieve(body_name)) {
  1332.                 ud = unit_decl_get(body_name);
  1333.                 unit_unam  = ud->ud_unam;
  1334.                 s_info     = ud->ud_symbols;
  1335.                 decscopes  = ud->ud_decscopes;
  1336.                 decmaps    = ud->ud_decmaps;
  1337.  
  1338.                 /* Restore symbol table entries.*/
  1339.                 symtab_restore(s_info);
  1340.  
  1341.                 /* (for decls = decmap(scope)) 
  1342.                  *    declared(scope) := decls; 
  1343.                  * end; 
  1344.                  */
  1345.                 FORTUPI(scope=(Symbol), decscopes, i, ft1);
  1346.                     DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  1347.                 ENDFORTUP(ft1);
  1348.             }
  1349.             dcl_undef(DECLARED(symbol_standard0), nam);
  1350.             dcl_put(DECLARED(symbol_standard0), nam, unit_unam);
  1351.         }
  1352.         return unit;
  1353.     }
  1354.     else {         /* Unit is not in library*/
  1355.         id_node = node_new(as_simple_name);
  1356.         N_VAL(id_node) = (char *) nam;
  1357.         check_old(id_node);
  1358.         if (N_UNQ(id_node) == symbol_undef) {     /* safe to add it, */
  1359.             namsym = find_new(N_VAL(id_node));    /* To avoid error */
  1360.             N_UNQ(id_node) = namsym;
  1361. #ifdef TBSL
  1362.             visible(nam) :
  1363.             = {
  1364.             };              
  1365.             $ in subsequent USE
  1366. #endif
  1367.         }
  1368.         return strjoin("","");
  1369.     }
  1370. }
  1371.  
  1372. static void elaborate_pragma(Node node)                    /*;elaborate_pragma*/
  1373. {
  1374.     Node    arg_list_node;
  1375.     Node    i_node, e_node, name_node, arg_node;
  1376.     Tuple    arg_list;
  1377.     Fortup    ft1;
  1378.     char    *nam;
  1379.  
  1380.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : elaborate_pragma");
  1381.  
  1382.     arg_list_node = N_AST2(node);
  1383.     arg_list = N_LIST(arg_list_node);
  1384.     FORTUP(arg_node=(Node), arg_list, ft1);
  1385.         i_node    = N_AST1(arg_node);
  1386.         e_node = N_AST2(arg_node);
  1387.         /*For now, disregard named associations.*/
  1388.         if (cdebug2 > 3) TO_ERRFILE("all_vis : ");
  1389.         name_node = N_AST1(e_node);       /* extract simple_name node.*/
  1390.         nam = N_VAL(name_node);
  1391.         if (tup_memstr(strjoin("sp", nam), all_vis)) {
  1392.             /*if ['spec', nam] in all_vis then*/
  1393.             elab_pragmas =tup_with(elab_pragmas, strjoin("bo", nam));
  1394.             /* package body needed.*/
  1395.         }
  1396.         else if (tup_memstr(strjoin("ss", nam), all_vis)) {
  1397.             elab_pragmas =tup_with(elab_pragmas, strjoin("su", nam));
  1398.             /* subprogram body needed.*/
  1399.         }
  1400.         else if (tup_memstr(strjoin("su", nam), all_vis)) {
  1401.             ;    /* already listed.*/
  1402.         }
  1403.         else {
  1404.             warning(strjoin(strjoin(
  1405.                  "Unknown unit name in ELABORATE pragma ", nam),
  1406.               "10.5"), name_node);
  1407.         }
  1408.     ENDFORTUP(ft1);
  1409. }
  1410.  
  1411. void stub_head(int nat, Node id_node)                        /*;stub_head*/
  1412. {
  1413.     /* Find unique name of package or task stub, and verify that it occurs
  1414.      * in the proper scope.
  1415.      */
  1416.  
  1417.     char    *id;
  1418.     Symbol    stub_name;
  1419.  
  1420.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  stub_head");
  1421.  
  1422.     find_old(id_node);
  1423.     id = N_VAL(id_node);
  1424.     stub_name = N_UNQ(id_node);
  1425.  
  1426.     if (SCOPE_OF(stub_name) != scope_name ) {
  1427. #ifdef ERRNUM
  1428.         str_errmsgn(15, id, 16, id_node);
  1429. #else
  1430.         errmsg_str("specification and stub for % are in different scopes", id,
  1431.           "7.1, 9.1", id_node);
  1432. #endif
  1433.     }
  1434.  
  1435.     /* Nature of specification must match that of stub.*/
  1436.  
  1437.     if ((nat == na_package && (NATURE(stub_name) != na_package_spec
  1438.       && NATURE(stub_name) != na_generic_package_spec))
  1439.       || (nat == na_task && (NATURE(stub_name) != na_task_type_spec
  1440.       && NATURE(stub_name) != na_task_obj_spec)) ) {
  1441. #ifdef ERRNUM
  1442.         str_errmsgn(17, id, 16, id_node);
  1443. #else
  1444.         errmsg_str("Matching specification not found for stub %", id,
  1445.           "7.1, 9.1", id_node);
  1446. #endif
  1447.         if (DECLARED(stub_name) == (Declaredmap)0) 
  1448.             DECLARED(stub_name) = dcl_new(0);
  1449.     }
  1450. }
  1451.  
  1452. void save_stub(Node node)                            /*;save_stub*/
  1453. {
  1454.     char    *kind, *stub_name;
  1455.     char    *other_unit;
  1456.     Symbol    name, unit_unam;
  1457.     Node    spec_node, id_node, stmt_node;
  1458.     Tuple    env_scope_st, tup;
  1459.     Fortup    ft1;
  1460.     int    i, si;
  1461.     Stubenv ev;
  1462.  
  1463.     if (N_KIND(node) ==  as_subprogram_stub) {
  1464.         spec_node = N_AST1(node);
  1465.         stmt_node = N_AST3(node);
  1466.         id_node = N_AST1(spec_node);
  1467.         kind = "su";
  1468.         /* Transform the node to as_subprogram_stub_tr nearby dropping off the
  1469.          * specification part which contains unnecessary conformance info (in
  1470.          * the formal part). Also the node as_procedure (as_function) is 
  1471.          * unnecessary since this can be determined from the symbol table. Now 
  1472.          * we move the id_node info (name of the subprogram) to the 
  1473.          * as_subprogram_stub_tr node directly and move the statments node to
  1474.          * the N_AST1 field so that the N_UNQ field (N_AST3) can be used.
  1475.          */
  1476.         N_KIND(node) = as_subprogram_stub_tr;
  1477.         N_AST1(node) = stmt_node;
  1478.         N_UNQ(node) = N_UNQ(id_node);
  1479.     }
  1480.     else {            /* package or task stub */
  1481.         id_node = node;
  1482.         kind  = "bo";
  1483.     }
  1484.  
  1485.     /* Save current state of compilation : scope stack and related declared
  1486.      * maps, for a subprogram or module stub.
  1487.      */
  1488.     name = N_UNQ(id_node);
  1489.  
  1490.     if (cdebug2 > 3) TO_ERRFILE(strjoin("save_stub: ", original_name(name)));
  1491.  
  1492.     /* In order to uniquely identify the stub, we create for it a name which
  1493.      * includes the names of all surrounding scopes, with the exception of
  1494.      * the ever-present standard environment and its enclosing scope.
  1495.      */
  1496.     stub_name = strjoin(kind, original_name(name));
  1497.     i = tup_size(open_scopes)-2;
  1498.     stub_name = strjoin(stub_name, ".");
  1499.     stub_name = strjoin(stub_name, original_name((Symbol) open_scopes[1]));
  1500.     if (i != 1) {
  1501.         stub_name = strjoin(stub_name, ".");
  1502.         stub_name = strjoin(stub_name, original_name((Symbol) open_scopes[i]));
  1503.     }
  1504.     /* Ada requires that the identifiers of all subunits of a given library
  1505.      * unit (as well as the name of the library unit itself) be unique.
  1506.      * Check to see of there exists another sub_unit that has the same
  1507.      * identifier a different parent but the same eldest ancestor.
  1508.      */
  1509.     FORTUP(other_unit=(char *), lib_stub, ft1);
  1510.         if (streq(unit_name_name(other_unit), unit_name_name(stub_name))
  1511.           && streq(stub_ancestor(other_unit), stub_ancestor(stub_name)))
  1512. #ifdef ERRNUM
  1513.             errmsgn(18, 19, id_node);
  1514. #else
  1515.         errmsg("Subunit identifier not unique", "10.2", id_node);
  1516. #endif
  1517.     ENDFORTUP(ft1);
  1518.  
  1519.     /* Verify that the stub appears immediately within a compilation unit.*/
  1520.     if (!streq(original_name(scope_name), unit_name_name(unit_name)))
  1521. #ifdef ERRNUM
  1522.         l_errmsgn(20, 21, 19, id_node);
  1523. #else
  1524.         errmsg_l("stubs can only appear in the outermost scope of a " ,
  1525.           "compilation unit", "10.2", id_node);
  1526. #endif
  1527.  
  1528.     /* Install the new stub into the library. */
  1529.     update_lib_maps(stub_name, 's');
  1530.  
  1531.     /* Save stub environment. 
  1532.      * Perhaps some optimization can be done by have a pointer to the symbol 
  1533.      * table of the parent instead of a complete copy for each stub.
  1534.      *
  1535.      * open_decls := {};
  1536.      * (forall decl = declared(os))
  1537.      *    open_decls(os) := {[nam, decl(nam), SYMBTABF(decl(nam))] :
  1538.      *            nam in domain decl};
  1539.      * end forall;
  1540.      */
  1541.  
  1542.     /*unit_unam := declared('STANDARD#0')(stub_name(#stub_name)); */
  1543.     unit_unam = dcl_get(DECLARED(symbol_standard0), stub_ancestor(stub_name));
  1544.  
  1545.     env_scope_st = tup_new(0);
  1546.     FORTUP(tup=(Tuple), scope_st, ft1);
  1547.         env_scope_st = tup_with(env_scope_st, (char *) tup_copy(tup));
  1548.     ENDFORTUP(ft1);
  1549.     tup = tup_new(4);
  1550.     tup[1] = (char *) scope_name;
  1551.     tup[2] = (char *) tup_copy(open_scopes);
  1552.     tup[3] = (char *) tup_copy(used_mods);
  1553.     tup[4] = (char *) tup_copy(vis_mods);
  1554.     env_scope_st = tup_with(env_scope_st, (char *) tup);
  1555.     /* STUB_ENV(stub_name) :=
  1556.      * [ (scope_st + [scope_info]),
  1557.      *   open_decls,
  1558.      *   {[vm, visible(vm)] : vm in vis_mods | vm notin ignore},
  1559.      *   unit_unam,
  1560.      *   SYMBTABF(unit_unam),
  1561.      *   CONTEXT
  1562.      *  ];
  1563.      */
  1564.     ev = (Stubenv) stubenv_new();
  1565.     ev->ev_scope_st = env_scope_st;
  1566.     ev->ev_open_decls = unit_symbtab(unit_unam, 's');
  1567.     ev->ev_nodes = tup_copy(unit_nodes);
  1568.     ev->ev_unit_unam = unit_unam;
  1569.     ev->ev_decmap = dcl_copy(DECLARED(unit_unam));
  1570.     ev->ev_context = tup_copy(context);
  1571.  
  1572.     if (NATURE(name) == na_task_obj_spec)
  1573.         /* Task object. The stub applies to the task type, not the object. */
  1574.         N_UNQ(id_node) = TYPE_OF(name);
  1575.  
  1576.     N_VAL(node) = stub_name;
  1577.     /* Install pointer to saved stub environment */
  1578.     si = stub_numbered(stub_name);
  1579.     tup = (Tuple) stub_info[si];
  1580.     tup[2] = (char *) ev;
  1581.     stub_parent_put(stub_name, unit_name);
  1582.     stubs_to_write = set_with(stubs_to_write, (char *) si);
  1583.  
  1584.     /* allocate a fake proper body for the stub. Needed for handling of
  1585.      * generic stubs.
  1586.      */
  1587.     si = unit_number(stub_name);
  1588.     pUnits[si]->libInfo.obsolete = string_ds; /*"$D$"*/
  1589. }
  1590.  
  1591. static Tuple check_separate(Node unit_node)                /*;check_separate*/
  1592. {
  1593.     /* This procedure restores the environment saved for a stub,
  1594.      * including the original scope stack.
  1595.      */
  1596.  
  1597.     Node    a_node, proper_node, spec, name_node;
  1598.     char    *name, *parent_unit, *outer_most;
  1599.     int    parent_num;
  1600.     Symbol    unit_unam;
  1601.     Stubenv ev;
  1602.  
  1603.     a_node    = N_AST1(unit_node);
  1604.     proper_node = N_AST2(unit_node);
  1605.  
  1606.     /*  Find identifier of subunit. */
  1607.     if (N_KIND(proper_node) == as_subprogram) {
  1608.         spec = N_AST1(proper_node);
  1609.         name_node = N_AST1(spec);
  1610.     }
  1611.     else     /* package body.*/
  1612.         name_node = N_AST1(proper_node);
  1613.     name = N_VAL(name_node);
  1614.  
  1615.     if (cdebug2 > 3) TO_ERRFILE(strjoin("checking separate: ", name));
  1616.  
  1617.     ev = (Stubenv) retrieve_env(a_node, name_node);
  1618.     if (ev != (Stubenv)0) {
  1619.         scope_st = ev->ev_scope_st;
  1620.         unit_unam = ev->ev_unit_unam;
  1621.         parent_num = stub_parent_get(unit_name);
  1622.         parent_unit = pUnits[parent_num]->name;
  1623.         all_vis = tup_with(all_vis, (char *)parent_unit);
  1624.         /* put name of outer-most scope in standard*/
  1625.         outer_most = stub_ancestor(unit_name);
  1626.         dcl_undef(DECLARED(symbol_standard0), outer_most);
  1627.         dcl_put(DECLARED(symbol_standard0), outer_most, unit_unam);
  1628.  
  1629.         /* Reestablish scope of the parent unit, in which compilation of the
  1630.          * subunit will take place.
  1631.          */
  1632.         popscope();
  1633. #ifdef TBSL
  1634.         /* Initialize visibility info. */
  1635.         (forall vis_vm = vis(vm))
  1636.             visible(vm) :
  1637.         = vis_vm;
  1638.         declared(vm) :
  1639.         = vis_vm;
  1640.         end forall;
  1641. #endif
  1642.         DECLARED(unit_unam) = dcl_copy(ev->ev_decmap);
  1643.         symtab_restore(ev->ev_open_decls);
  1644.         return ev->ev_context;
  1645.     }
  1646.     else return (Tuple)0; /* to indicate error */
  1647. }
  1648.  
  1649. static Stubenv retrieve_env(Node a_node, Node name_node)    /*;retrieve_env*/
  1650. {
  1651.     /* Obtain the sequence of parent units of the  subunit. It may be an
  1652.      * expanded name listing all ancestors.
  1653.      */
  1654.  
  1655.     Node    id_node;
  1656.     char    *name, *expd_name, *stub_nam, *stub_name;
  1657.     Fortup    ft1;
  1658.     Tuple    tup;
  1659.     int    si, stub_err;
  1660.  
  1661.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  retrieve_env");
  1662.  
  1663.     name = N_VAL(name_node);
  1664.     expd_name = strjoin(name, "");
  1665.     if (N_KIND(a_node) != as_simple_name) {
  1666.         id_node = N_AST2(a_node);
  1667.         expd_name = strjoin(expd_name, ".");
  1668.         expd_name = strjoin(expd_name, N_VAL(id_node));
  1669.     }
  1670.     while (N_KIND(a_node) != as_simple_name) a_node = N_AST1(a_node);
  1671.     expd_name = strjoin(expd_name, ".");
  1672.     expd_name = strjoin(expd_name, N_VAL(a_node));
  1673.     /* retrieve from library the environment in which a stub was
  1674.      * first seen.
  1675.      */
  1676.  
  1677.     stub_err = FALSE;
  1678.     stub_name = (char *) 0;
  1679.     FORTUP(stub_nam=(char *), lib_stub, ft1);
  1680.         if (streq(unit_name_names(stub_nam), expd_name)) {
  1681.             if (stub_name == (char *)0) stub_name = stub_nam;
  1682.             else if (!streq(stub_name, stub_nam)) stub_err = TRUE;
  1683.         }
  1684.     ENDFORTUP(ft1);
  1685.  
  1686.     if (stub_name == (char *) 0) stub_err = TRUE;
  1687.  
  1688.     if (stub_err || !stub_retrieve(stub_name)) {
  1689. #ifdef ERRNUM
  1690.         str_errmsgn(22, name, 19, name_node);
  1691. #else
  1692.         errmsg_str("cannot find stub for subunit %", name, "10.2" , name_node);
  1693. #endif
  1694.         unit_name = strjoin("","");
  1695.         return (Stubenv)0;
  1696.     }
  1697.     remove_obsolete_stubs(expd_name);
  1698.     unit_name = strjoin(stub_name, "");
  1699.     seq_symbol_n = 0;
  1700.     init_compunit();
  1701.     si = stub_number(stub_name);
  1702.     tup = (Tuple) stub_info[si];
  1703.     return (Stubenv) tup[2];
  1704. }
  1705.  
  1706. static void remove_obsolete_stubs(char *name) /*;remove_obsolete_stubs*/
  1707. {
  1708.     /* If this unit was previously compiled remove possible obsolete stubs 
  1709.      * of it from library.
  1710.      */
  1711.  
  1712.     char     *stub;
  1713.     Fortup  ft1;
  1714.  
  1715.     FORTUP(stub=(char *), lib_stub, ft1);
  1716.         if (streq(stub_ancestors(stub), name))
  1717.             lib_stub_put(stub, (char *)0);
  1718.     ENDFORTUP(ft1);
  1719. }
  1720.